home *** CD-ROM | disk | FTP | other *** search
- ;;; fuzzy-match.el --- fuzzy matching
-
- ;; Copyright (C) 1993 Simon Marshall.
-
- ;; Author: Simon Marshall <s.marshall@dcs.hull.ac.uk>
- ;; Keywords: matching strings
- ;; Version: 1.00
-
- ;; This file is not part of GNU Emacs.
-
- ;; GNU Emacs is free software; you can redistribute it and/or modify
- ;; it under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation; either version 2, or (at your option)
- ;; any later version.
-
- ;; GNU Emacs is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;; GNU General Public License for more details.
-
- ;; You should have received a copy of the GNU General Public License
- ;; along with GNU Emacs; see the file COPYING. If not, write to
- ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ;;; Commentary:
-
- ;;; This is fuzzy software. Use it at your own risk.
-
- ;;; Please send me bug reports, bug fixes, and extensions, so that I can
- ;;; merge them into the master source.
- ;;; - Simon Marshall (s.marshall@dcs.hull.ac.uk)
-
- (defsubst FM-string-to-char-list (string)
- "Return the character list of STRING.
- If STRING is already a list, this function just returns STRING."
- (if (listp string)
- string
- (mapcar (function (lambda (char) char)) string)))
-
- (defsubst FM-strings-to-char-lists (strings)
- "Return the character lists of STRINGS.
- See `FM-string-to-char-list'."
- (mapcar (function (lambda (string) (FM-string-to-char-list string)))
- strings))
-
- (defsubst FM-char-list-to-string (charlist)
- "Return the string of CHARLIST.
- If CHARLIST is not a list, this function just returns CHARLIST."
- (if (listp charlist)
- (mapconcat (function (lambda (char) (char-to-string char))) charlist "")
- charlist))
-
- (defsubst FM-char-lists-to-strings (charlists)
- "Return the strings of CHARLISTS.
- See `FM-char-list-to-string'."
- (mapcar (function (lambda (charlist) (FM-char-list-to-string charlist)))
- charlists))
-
-
- (defsubst FM-strstr-intern (string1 string2)
- "Find first occurrence of a prefix of STRING1 in STRING2.
- Returns a cons pair of the length of the substring and the offset into STRING2,
- or nil if no match is found.
- STRING1 and STRING2 are character lists."
- (let ((char1 (car string1))
- (offset 0) (len 1))
- (while (and string2 (/= char1 (car string2)))
- (setq offset (1+ offset) string2 (cdr string2)))
- (if (null string2)
- nil
- (setq string1 (cdr string1) string2 (cdr string2))
- (while (and string1 string2 (= (car string1) (car string2)))
- (setq len (1+ len) string1 (cdr string1) string2 (cdr string2)))
- (cons len offset))))
-
-
- (defsubst FM-matchiness-intern (string1 string2)
- "Return the fuzziness between STRING1 and STRING2.
- STRING1 and STRING2 are character lists."
- (let* ((fuzz 0) match len)
- (while (and string1 string2)
- (setq match (FM-strstr-intern string1 string2))
- (if (or (null match) (< (car match) (cdr match)))
- (setq string1 (cdr string1))
- (setq len (car match)
- fuzz (+ fuzz len)
- string1 (nthcdr len string1)
- string2 (nthcdr (+ len (cdr match)) string2))))
- fuzz))
-
-
- (defun FM-string-prefix (string1 string2)
- "Return length of prefix of STRING1 that starts STRING2.
- STRING1 and STRING2 can be character lists."
- (let ((string1 (FM-string-to-char-list string1))
- (string2 (FM-string-to-char-list string2))
- (prefix 0))
- (while (and string1 string2 (= (car string1) (car string2)))
- (setq prefix (1+ prefix)
- string1 (cdr string1)
- string2 (cdr string2)))
- prefix))
-
-
- (defun FM-lessiness (string string1 string2)
- "Return non-nil if STRING1 is \"less\" than STRING2, based on STRING.
- Comparison is based on the simularity between STRING, and the length of STRING1
- and STRING2. The closer the start of a string to STRING, the better. If they
- both share the same substring, the comparision is based on length.
- STRING, STRING1 and STRING2 can be character lists."
- (let* ((prefix1 (FM-string-prefix string string1))
- (prefix2 (FM-string-prefix string string2)))
- (if (/= prefix1 prefix2)
- (> prefix1 prefix2)
- (< (length string1) (length string2)))))
-
- ;;; Useful functions...
-
- (defun FM-matchiness (string1 string2)
- "Return the fuzziness between STRING1 and STRING2.
- STRING1 and STRING2 can be character lists."
- (FM-matchiness-intern (FM-string-to-char-list string1)
- (FM-string-to-char-list string2)))
-
-
- (defun FM-all-fuzzy-matches (string strings)
- "Return most fuzzy matches to STRING in STRINGS.
- Each element of STRINGS is tested to see if it fuzzily matches STRING.
- The value is a list of all the strings from STRINGS that most fuzzily match.
- The list of fuzzy matches is sorted using `FM-lessiness' as predicate.
- STRING and elements of STRINGS can be character lists."
- (let* ((string (FM-string-to-char-list string))
- (strings (FM-strings-to-char-lists strings))
- (bestfuzz (FM-matchiness-intern string (car strings)))
- (matches (list (car strings)))
- (strings (cdr strings))
- thisfuzz)
- (while strings
- (setq thisfuzz (FM-matchiness-intern string (car strings)))
- (cond ((= bestfuzz thisfuzz)
- (setq matches (cons (car strings) matches)))
- ((< bestfuzz thisfuzz)
- (setq bestfuzz thisfuzz
- matches (list (car strings)))))
- (setq strings (cdr strings)))
- (FM-char-lists-to-strings
- (sort matches (function (lambda (string1 string2)
- (FM-lessiness string string1 string2)))))))
-
-
- (defun FM-lisp-symbol (string)
- "Return a list of fuzzy matches for the lisp symbol STRING.
- STRING can be a character list.
- This function is slow, since it checks each symbol in `obarray' in lisp.
- See also `FM-lisp-symbol-quick' and `FM-all-fuzzy-matches'."
- (FM-all-fuzzy-matches string (all-completions "" obarray)))
-
-
- (defun FM-lisp-symbol-quick (string)
- "Return a list of fuzzy matches for the lisp symbol STRING.
- STRING can be a character list.
- This function cheats, since it reduces the number of lisp code tests by using
- only those symbols from `obarray' that begin with the same substring as STRING.
- This means that the fewer correct letters at the beginning of STRING, the
- longer this function will take, and if the incorrect letters match some valid
- symbol, the wrong symbols will be matched.
- See also `FM-lisp-symbol', `FM-all-fuzzy-matches', and `all-completions'."
- (let* ((string (FM-char-list-to-string string))
- (len (length string)) (end len)
- (completions (all-completions string obarray)))
- (while (and (> end 0) (null completions))
- (setq end (1- end)
- completions (all-completions (substring string 0 end) obarray)))
- (FM-all-fuzzy-matches string completions)))
-
-
- (defun FM-replace-by-matched-lisp-symbol ()
- "Replace lisp symbol before point with best fuzzy match."
- (interactive)
- (let ((sym (FM-lisp-symbol-at-point)))
- (replace-match (car (FM-lisp-symbol-quick sym)) t t)))
-
-
- (defun FM-list-lisp-symbols ()
- "List in help buffer fuzzy matches to lisp symbol before point."
- (interactive)
- (let ((sym (FM-lisp-symbol-at-point)))
- (FM-dynamic-list-matches (FM-lisp-symbol-quick sym))))
-
-
- (defun FM-pathname (pathname)
- (let ((fmpath "")
- (start 0) end partpath fmpartpath)
- (while start
- (setq end (string-match "/" pathname (1+ start))
- partpath (substring pathname start end)
- fmpartpath (concat fmpath partpath)
- fmpath (if (file-exists-p fmpartpath)
- fmpartpath
- (car (FM-all-fuzzy-matches
- fmpartpath (directory-files fmpath t))))
- start end))
- fmpath))
-
-
- (defun FM-replace-by-matched-filename ()
- "Replace filename before point with best fuzzy match."
- (interactive)
- (let ((path (FM-pathname-at-point)))
- (replace-match (save-match-data (FM-pathname path)) t t)))
-
-
- (defun FM-replace-by-matched-command ()
- "Replace command name before point with best fuzzy match."
- (interactive)
- (let* ((command (file-name-nondirectory (FM-pathname-at-point)))
- (stub (substring command 0 1))
- (paths (cdr (reverse exec-path)))
- (ignored-extensions
- (mapconcat (function (lambda (x) (concat (regexp-quote x) "$")))
- completion-ignored-extensions "\\|"))
- path cmd cmds commands)
- (save-match-data
- (while paths
- (setq path (file-name-as-directory (car paths)) paths (cdr paths)
- cmds (and (file-accessible-directory-p path)
- (file-name-all-completions stub path)))
- (while cmds
- (setq cmd (car cmds) cmds (cdr cmds))
- (if (and (not (member cmd commands))
- (not (string-match ignored-extensions cmd))
- (not (file-directory-p (concat path cmd)))
- (file-executable-p (concat path cmd)))
- (setq commands (cons cmd commands))))))
- (replace-match (car (FM-all-fuzzy-matches command commands)) t t)))
-
- ;;; Plundered from comint.el.
-
- (defun FM-pathname-at-point ()
- "Return the expanded filename at point, or signal an error.
- Environment variables are substituted."
- (save-excursion
- (if (re-search-backward "[^~/A-Za-z0-9_.$#,={}()-]" nil 'move)
- (forward-char 1))
- ;; Anchor the search forwards.
- (if (not (looking-at "[~/A-Za-z0-9_.$#,={}()-]")) (error ""))
- (re-search-forward "[~/A-Za-z0-9_.$#,={}()-]+")
- (expand-file-name
- (substitute-in-file-name
- (buffer-substring (match-beginning 0) (match-end 0))))))
-
- (defun FM-lisp-symbol-at-point ()
- "Return the lisp symbol at point, or signal an error."
- (save-excursion
- (if (re-search-backward "[^A-Za-z0-9_.$#,=-]" nil 'move)
- (forward-char 1))
- ;; Anchor the search forwards.
- (if (not (looking-at "[A-Za-z0-9_.$#,=-]")) (error ""))
- (re-search-forward "[~/A-Za-z0-9_.$#,=-]+")
- (buffer-substring (match-beginning 0) (match-end 0))))
-
- (defun FM-dynamic-list-matches (matches)
- "List in help buffer MATCHES.
- Typing SPC flushes the help buffer."
- (let ((conf (current-window-configuration))
- (match-buffer " *Matches*"))
- (with-output-to-temp-buffer match-buffer
- (display-completion-list matches)
- (set-buffer match-buffer)
- (forward-line 3)
- (while (search-backward "completion" nil 'move)
- (replace-match "candidate")))
- (sit-for 0)
- (message "Hit space to flush")
- (let ((ch (read-event)))
- (if (eq ch ?\ )
- (set-window-configuration conf)
- (setq unread-command-events (list ch))))))
-
- ;;; fuzzy-match.el ends here
-